(define (uctmw:compile-program sc-prog)
  (define (check-program fundef*)
    (if (not (syntax-match?
               '(define)
               '((define (fname par ...) body) ...)
               fundef*))
      (begin (error "ill-formed function definition list" fundef*)))
    (for-each
      (lambda (fundef)
        (let ((body (caddr fundef))
              (pars (cdadr fundef))
              (fname (caadr fundef)))
          (if (or (not (symbol? fname))
                  (not (and-map symbol? pars))
                  (duplicate-symbols? pars))
            (begin (error "ill-formed function definition")))))
      fundef*))
  (define (make-fun-env fundef*) (map cadr fundef*))
  (define (compile-fundef-list fundef* funenv)
    (map (lambda (fundef) (compile-fundef fundef funenv)) fundef*))
  (define (compile-fundef fundef funenv)
    (let ((body (caddr fundef)) (pars (cdadr fundef)) (fname (caadr fundef)))
      (let ((%%128 (compile-exp body pars funenv)))
        (let ((exp %%128)) `(,fname ,pars = ,exp)))))
  (define (compile-exp exp varenv funenv)
    (check-exp exp varenv funenv)
    (cond ((symbol? exp) exp)
          ((literal? exp) `',exp)
          ((equal? (car exp) 'quote) exp)
          ((equal? (car exp) 'quasiquote)
           (let ((template (cadr exp)))
             (compile-template template 1 varenv funenv)))
          ((equal? (car exp) 'list)
           (let ((exp* (cdr exp)))
             (compile-exp
               (foldr (lambda (exp1 exp0) `(cons ,exp1 ,exp0)) ''() exp*)
               varenv
               funenv)))
          ((equal? (car exp) 'if)
           (let ((exp3 (cadddr exp)) (exp2 (caddr exp)) (exp1 (cadr exp)))
             (gen-if (compile-exp exp1 varenv funenv)
                     (compile-exp exp2 varenv funenv)
                     (compile-exp exp3 varenv funenv))))
          ((equal? (car exp) 'cond)
           (let ((clause* (cdr exp))) (compile-cond clause* varenv funenv)))
          ((equal? (car exp) 'let)
           (let ((exp0 (caddr exp)) (bindings (cadr exp)))
             (gen-let (compile-bindings bindings varenv funenv)
                      (compile-exp
                        exp0
                        (extend-varenv bindings varenv)
                        funenv))))
          ((equal? (car exp) 'let*)
           (let ((exp0 (caddr exp)) (binding* (cadr exp)))
             (compile-exp
               (foldr (lambda (binding body) `(let (,binding) ,body))
                      exp0
                      binding*)
               varenv
               funenv)))
          ((equal? (car exp) 'case)
           (let ((clause* (cddr exp)) (key (cadr exp)))
             (compile-exp (expand-case key clause*) varenv funenv)))
          ((equal? (car exp) 'begin)
           (let ((exp+ (cdr exp)))
             (compile-exp (car (last-pair exp+)) varenv funenv)))
          ((equal? (car exp) 'and)
           (let ((exp* (cdr exp)))
             (compile-exp (expand-and exp*) varenv funenv)))
          ((equal? (car exp) 'or)
           (let ((exp* (cdr exp)))
             (compile-exp (expand-or exp*) varenv funenv)))
          ((equal? (car exp) 'error)
           (let ((exp* (cdr exp)))
             `(error unquote (compile-exp* exp* varenv funenv))))
          ((equal? (car exp) 'rcall)
           (let ((exp1 (cadr exp)))
             (gen-rcall (compile-exp exp1 varenv funenv))))
          ((equal? (car exp) 'generalize)
           (let ((exp1 (cadr exp)))
             `(generalize ,(compile-exp exp1 varenv funenv))))
          (else
           (let ((exp* (cdr exp)) (fname (car exp)))
             (let ((fdescr (assq fname funenv)))
               (cond (fdescr
                      `(call ,fname unquote (compile-exp* exp* varenv funenv)))
                     ((c...r? fname)
                      (compile-exp (expand-c...r exp) varenv funenv))
                     ((ux:macro? fname)
                      (compile-exp (ux:macroexpand-1 exp) varenv funenv))
                     (else
                      (make-xcall
                        fname
                        (compile-exp* exp* varenv funenv)))))))))
  (define (compile-exp* exp* varenv funenv)
    (map (lambda (exp) (compile-exp exp varenv funenv)) exp*))
  (define (compile-cond clause* varenv funenv)
    (cond ((null? clause*) ''*unspecified*)
          ((and (pair? clause*)
                (pair? (car clause*))
                (equal? (caar clause*) 'else)
                (pair? (cdar clause*))
                (null? (cddar clause*)))
           (let ((exp (cadar clause*))) (compile-exp exp varenv funenv)))
          ((and (pair? clause*)
                (pair? (car clause*))
                (pair? (cdar clause*))
                (null? (cddar clause*)))
           (let ((rest (cdr clause*))
                 (exp (cadar clause*))
                 (test (caar clause*)))
             (gen-if (compile-exp test varenv funenv)
                     (compile-exp exp varenv funenv)
                     (compile-cond rest varenv funenv))))
          (else (error "MATCH: no match for" clause*))))
  (define (compile-template t depth varenv funenv)
    (cond ((= depth 0) (compile-exp t varenv funenv))
          ((or (null? t)
               (boolean? t)
               (number? t)
               (char? t)
               (string? t)
               (symbol? t))
           `',t)
          ((vector? t)
           `(vector unquote
                    (map (lambda (x) (compile-template x depth varenv funenv))
                         (vector->list t))))
          ((and (pair? t)
                (equal? (car t) 'unquote)
                (pair? (cdr t))
                (null? (cddr t)))
           (let ((x (cadr t)))
             (if (= depth 1)
               (compile-exp x varenv funenv)
               (mk-unary
                 'unquote
                 (compile-template x (- depth 1) varenv funenv)))))
          ((and (pair? t)
                (equal? (car t) 'quasiquote)
                (pair? (cdr t))
                (null? (cddr t)))
           (let ((x (cadr t)))
             (mk-unary
               'quasiquote
               (compile-template x (+ 1 depth) varenv funenv))))
          ((and (pair? t)
                (pair? (car t))
                (equal? (caar t) 'unquote-splicing)
                (pair? (cdar t))
                (null? (cddar t)))
           (let ((t2 (cdr t)) (x (cadar t)))
             (if (= depth 1)
               `(append ,(compile-exp x varenv funenv)
                        ,(compile-template t2 depth varenv funenv))
               `(cons ,(mk-unary
                         'unquote-splicing
                         (compile-template x (- depth 1) varenv funenv))
                      ,(compile-template t2 depth varenv funenv)))))
          ((pair? t)
           (let ((t2 (cdr t)) (t1 (car t)))
             `(cons ,(compile-template t1 depth varenv funenv)
                    ,(compile-template t2 depth varenv funenv))))
          (else (error "MATCH: no match for" t))))
  (define (mk-unary key arg) `(cons ',key (cons ,arg '())))
  (define (compile-bindings bindings varenv funenv)
    (map (lambda (binding)
           (let ((exp (cadr binding)) (vname (car binding)))
             `(,vname ,(compile-exp exp varenv funenv))))
         bindings))
  (define (expand-case key clause*)
    (if (symbol? key)
      `(cond unquote
             (map (lambda (clause) (expand-case-clause key clause)) clause*))
      (let ((x (ux:gentemp)))
        `(let ((,x ,key))
           (cond unquote
                 (map
                  (lambda (clause) (expand-case-clause x clause))
                  clause*))))))
  (define (expand-case-clause x clause)
    (cond ((and (pair? clause) (equal? (car clause) 'else))
           (let ((exp* (cdr clause))) clause))
          ((and (pair? clause) (pair? (car clause)) (null? (cdar clause)))
           (let ((exp* (cdr clause)) (tag (caar clause)))
             `((eqv? ,x ',tag) unquote exp*)))
          ((and (pair? clause)
                (let ((exp* (cdr clause)) (tag* (car clause))) (list? tag*)))
           (let ((exp* (cdr clause)) (tag* (car clause)))
             `((memv ,x ',tag*) unquote exp*)))
          (else (error "ill-formed clause in case:" clause))))
  (define (expand-and exp*)
    (cond ((null? exp*) #t)
          ((and (pair? exp*) (null? (cdr exp*)))
           (let ((test (car exp*))) test))
          ((pair? exp*)
           (let ((rest (cdr exp*)) (test (car exp*)))
             (cond ((symbol? test) `(if ,test ,(expand-and rest) ,test))
                   ((boolean-result? test) `(if ,test ,(expand-and rest) #f))
                   (else
                    (let ((x (ux:gentemp)))
                      `(let ((,x ,test)) (if ,x ,(expand-and rest) ,x)))))))
          (else (error "MATCH: no match for" exp*))))
  (define (expand-or exp*)
    (cond ((null? exp*) #f)
          ((and (pair? exp*) (null? (cdr exp*)))
           (let ((test (car exp*))) test))
          ((pair? exp*)
           (let ((rest (cdr exp*)) (test (car exp*)))
             (cond ((symbol? test) `(if ,test ,test ,(expand-or rest)))
                   ((boolean-result? test) `(if ,test #t ,(expand-or rest)))
                   (else
                    (let ((x (ux:gentemp)))
                      `(let ((,x ,test)) (if ,x ,x ,(expand-or rest))))))))
          (else (error "MATCH: no match for" exp*))))
  (define (boolean-result? exp)
    (if (and (pair? exp) (let ((fname (car exp))) (symbol? fname)))
      (let ((fname (car exp)))
        (memq fname
              '(null? pair?
                      eq?
                      eqv?
                      equal?
                      =
                      >
                      <
                      >=
                      <=
                      not
                      boolean?
                      number?
                      symbol?
                      char?
                      string?
                      vector?)))
      #f))
  (define (extend-varenv bindings varenv)
    `(,@(map car bindings) unquote varenv))
  (define (make-xcall fname exp*)
    (if (memq fname '(static ifs ifd call rcall xcall))
      `(xcall ,fname unquote exp*)
      `(,fname unquote exp*)))
  (define (check-syntax pat exp)
    (if (not (syntax-match? '() (cdr pat) (cdr exp)))
      (error "ill-formed expression" exp)))
  (define (check-exp exp varenv funenv)
    (cond ((symbol? exp)
           (if (not (memq exp varenv)) (begin (error "unknown variable" exp))))
          ((literal? exp) #f)
          ((and (pair? exp) (let ((exp0 (car exp))) (not (symbol? exp0))))
           (let ((exp0 (car exp))) (check-syntax '(e e ...) exp)))
          ((and (pair? exp) (equal? (car exp) 'quote)) (check-arity exp 1))
          ((and (pair? exp) (equal? (car exp) 'quasiquote))
           (begin (check-arity exp 1) (check-template (cadr exp) 1)))
          ((and (pair? exp) (equal? (car exp) 'if)) (check-arity exp 3))
          ((and (pair? exp) (equal? (car exp) 'cond))
           (check-syntax '(cond (p e) ...) exp))
          ((and (pair? exp) (equal? (car exp) 'let))
           (begin
             (check-syntax '(let ((v e) ...) e) exp)
             (check-bindings (cadr exp))))
          ((and (pair? exp) (equal? (car exp) 'let*))
           (begin
             (check-syntax '(let ((v e) ...) e) exp)
             (check-bindings (cadr exp))))
          ((and (pair? exp) (equal? (car exp) 'case))
           (check-syntax '(case e (t e e ...) ...) exp))
          ((and (pair? exp) (equal? (car exp) 'and))
           (check-syntax '(and e ...) exp))
          ((and (pair? exp) (equal? (car exp) 'or))
           (check-syntax '(or e ...) exp))
          ((and (pair? exp) (equal? (car exp) 'error))
           (let ((exp* (cdr exp))) (check-syntax '(error exp1 exp2 ...) exp)))
          ((and (pair? exp) (equal? (car exp) 'rcall)) (check-arity exp 1))
          ((and (pair? exp) (equal? (car exp) 'generalize))
           (check-arity exp 1))
          ((and (pair? exp)
                (let ((exp* (cdr exp)) (fname (car exp)))
                  (and (symbol? fname) (list? exp*))))
           (let ((exp* (cdr exp)) (fname (car exp)))
             (if (memq fname '(define lambda set! set-car! set-cdr! letrec do))
               (begin (error "unacceptable expression" exp)))
             (if (memq fname ',unquote-splicing)
               (begin (error "misplaced unquotation" exp)))
             (if (memq fname varenv)
               (begin (error "a parameter used as a function name" exp)))
             (let ((fdescr (assq fname funenv)))
               (cond (fdescr (check-arity exp (length (cdr fdescr))))
                     ((built-in? fname)
                      (check-arity exp (built-in-arity fname)))
                     ((c...r? fname) (check-arity exp 1))
                     (else #f)))))
          (else (error "ill-formed expression" exp))))
  (define (check-template t depth)
    (cond ((= depth 0) #t)
          ((or (null? t)
               (boolean? t)
               (number? t)
               (char? t)
               (string? t)
               (symbol? t))
           #f)
          ((vector? t)
           (vector-for-each (lambda (x) (check-template x depth)) t))
          ((and (pair? t) (equal? (car t) 'unquote))
           (begin (check-arity t 1) (check-template (cadr t) (- depth 1))))
          ((and (pair? t) (equal? (car t) 'unquote-splicing))
           (error "misplaced unquotation" t))
          ((and (pair? t) (equal? (car t) 'quasiquote))
           (begin (check-arity t 1) (check-template (cadr t) (+ 1 depth))))
          ((pair? t)
           (let ((t2 (cdr t)) (t1 (car t)))
             (check-splicing t1 depth)
             (check-template t2 depth)))
          (else (error "MATCH: no match for" t))))
  (define (check-splicing t depth)
    (if (and (pair? t) (equal? (car t) 'unquote-splicing))
      (begin (check-arity t 1) (check-template (cadr t) (- depth 1)))
      (check-template t depth)))
  (define (check-bindings binding*)
    (for-each
      (lambda (binding)
        (if (and (pair? binding)
                 (pair? (cdr binding))
                 (null? (cddr binding))
                 (let ((exp (cadr binding)) (vname (car binding)))
                   (symbol? vname)))
          (let ((exp (cadr binding)) (vname (car binding))) '())
          (error "ill-formed binding list" binding*)))
      binding*)
    (if (duplicate-symbols? (map car binding*))
      (begin (error "Duplicate variables in bindings" binding*))))
  (define (check-arity exp arity)
    (if (not (list? exp)) (begin (error "ill-formed expression" exp)))
    (let ((exp* (cdr exp)) (fname (car exp)))
      (if (not (eqv? (length exp*) arity))
        (begin (error "Wrong number of argument expressions" exp)))))
  (define (gen-if exp0 exp1 exp2)
    (cond ((and (pair? exp0)
                (equal? (car exp0) 'quote)
                (pair? (cdr exp0))
                (null? (cddr exp0)))
           (let ((x (cadr exp0))) (if x exp1 exp2)))
          ((and (pair? exp0)
                (equal? (car exp0) 'if)
                (pair? (cdr exp0))
                (pair? (cddr exp0))
                (pair? (caddr exp0))
                (equal? (caaddr exp0) 'quote)
                (pair? (cdaddr exp0))
                (null? (cdr (cdaddr exp0)))
                (pair? (cdddr exp0))
                (pair? (cadddr exp0))
                (equal? (car (cadddr exp0)) 'quote)
                (pair? (cdr (cadddr exp0)))
                (null? (cddr (cadddr exp0)))
                (null? (cddddr exp0))
                (let ((y (cadr (cadddr exp0)))
                      (x (car (cdaddr exp0)))
                      (p (cadr exp0)))
                  (and (not x) y)))
           (let ((y (cadr (cadddr exp0)))
                 (x (car (cdaddr exp0)))
                 (p (cadr exp0)))
             `(if ,p ,exp2 ,exp1)))
          (else `(if ,exp0 ,exp1 ,exp2))))
  (define (gen-let bindings exp0)
    (if (null? bindings) exp0 `(let ,bindings ,exp0)))
  (define (gen-rcall exp)
    (if (equal? (car exp) 'call)
      (let ((exp* (cddr exp)) (fname (cadr exp))) `(rcall ,fname unquote exp*))
      (error "Expression cannot be annotated with 'rcall'" exp)))
  (define built-in-arities
    '((car . 1)
      (cdr . 1)
      (cons . 2)
      (null? . 1)
      (pair? . 1)
      (equal? . 2)
      (eq? . 2)
      (eqv? . 2)
      (not . 1)))
  (define (built-in? fname) (memq fname built-in-arities))
  (define (built-in-arity fname) (cdr (assq fname built-in-arities)))
  (define (c...r? fname) (assq fname c...r-list))
  (define (expand-c...r exp)
    (if (and (pair? exp)
             (pair? (cdr exp))
             (null? (cddr exp))
             (let ((exp1 (cadr exp)) (fname (car exp))) (symbol? fname)))
      (let ((exp1 (cadr exp)) (fname (car exp)))
        (let ((decomp (c...r? fname)))
          (if decomp
            (let ((sel2 (cddr decomp)) (sel1 (cadr decomp)))
              `(,sel1 ,(expand-c...r `(,sel2 ,exp1))))
            exp)))
      exp))
  (define c...r-list
    '((caar car . car)
      (cadr car . cdr)
      (cdar cdr . car)
      (cddr cdr . cdr)
      (caaar car . caar)
      (caadr car . cadr)
      (cadar car . cdar)
      (caddr car . cddr)
      (cdaar cdr . caar)
      (cdadr cdr . cadr)
      (cddar cdr . cdar)
      (cdddr cdr . cddr)
      (caaaar car . caaar)
      (caaadr car . caadr)
      (caadar car . cadar)
      (caaddr car . caddr)
      (cadaar car . cdaar)
      (cadadr car . cdadr)
      (caddar car . cddar)
      (cadddr car . cdddr)
      (cdaaar cdr . caaar)
      (cdaadr cdr . caadr)
      (cdadar cdr . cadar)
      (cdaddr cdr . caddr)
      (cddaar cdr . cdaar)
      (cddadr cdr . cdadr)
      (cdddar cdr . cddar)
      (cddddr cdr . cdddr)))
  (define (literal? x)
    (or (boolean? x) (number? x) (char? x) (string? x) (vector? x)))
  (check-program sc-prog)
  (let ((funenv (make-fun-env sc-prog))) (compile-fundef-list sc-prog funenv)))

